home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE05 / CLINIC / IMAGE2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-10-18  |  1.5 KB  |  72 lines
  1. unit Image2;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, ExtCtrls;
  8.  
  9. type
  10.   TNewImage = class(TImage)
  11.   private
  12.     FCanvas: TCanvas;
  13.     FBmp: TBitmap;
  14.   public
  15.     constructor Create(AOwner: TComponent); override;
  16.     destructor Destroy; override;
  17.     procedure WMPaint(var Msg: TWMPaint); message wm_Paint;
  18.     procedure Paint; override;
  19.   end;
  20.  
  21. procedure Register;
  22.  
  23. implementation
  24.  
  25. constructor TNewImage.Create(AOwner: TComponent);
  26. begin
  27.   inherited Create(AOwner);
  28.   { Can't draw on the TImage canvas - that turns }
  29.   { out to be the bitmap object's canvas }
  30.   FCanvas := TCanvas.Create;
  31.   { Temporary bitmap to cause palette realization }
  32.   FBmp := TBitmap.Create;
  33. end;
  34.  
  35. destructor TNewImage.Destroy;
  36. begin
  37.   FBmp.Free;
  38.   FCanvas.Free;
  39.   inherited Destroy;
  40. end;
  41.  
  42. procedure TNewImage.WMPaint(var Msg: TWMPaint);
  43. begin
  44.   { Identify what the real canvas is }
  45.   FCanvas.Handle := Msg.DC;
  46.   { Do normal stuff, like call Paint }
  47.   inherited;
  48.   { Now forget about it }
  49.   FCanvas.Handle := 0;
  50. end;
  51.  
  52. procedure TNewImage.Paint;
  53. begin
  54.   { Only do new stuff if it is a stretched image }
  55.   if (Picture.Graphic = nil) or not Stretch then
  56.     inherited Paint
  57.   else
  58.   begin
  59.     FBmp.Height := Picture.Height;
  60.     FBmp.Width  := Picture.Width;
  61.     FBmp.Canvas.Draw(0, 0, Picture.Graphic);
  62.     FCanvas.StretchDraw(ClientRect, FBmp);
  63.   end
  64. end;
  65.  
  66. procedure Register;
  67. begin
  68.   RegisterComponents('Samples', [TNewImage]);
  69. end;
  70.  
  71. end.
  72.